home *** CD-ROM | disk | FTP | other *** search
/ Softdisk Supreme / Softdisk Supreme.iso / pc / DSK Files / 0-49 / SD005b.dsk / CALENDAR.bas < prev    next >
BASIC Source File  |  2003-06-12  |  6KB  |  184 lines
  1. 90  REM CALENDAR PROGRAM
  2. 100  REM LIMITS OF CALENDAR
  3. 120  REM FROM 2-MARCH-1700
  4. 140  REM TO 31-JAN-2100<CTRL-J>
  5. 160  HOME : PRINT : PRINT 
  6. 180  DIM M$(12),J(12)
  7. 200  REM <CTRL-J>--DATA SECTION--<CTRL-J>
  8. 220  DATA  "JAN",31,"FEB",28,"MAR",31
  9. 240  DATA "APR",30,"MAY",31,"JUN",30
  10. 260  DATA  "JUL",31,"AUG",31,"SEP",30
  11. 280  DATA  "OCT",31,"NOV",30,"DEC",31
  12. 300  DATA  SUNDAY,MONDAY,TUESDAY
  13. 320  DATA  WEDNESDAY,THURSDAY
  14. 340  DATA  FRIDAY,SATURDAY
  15. 360  REM <CTRL-J>--READ SECTION--<CTRL-J>
  16. 380  FOR K = 1 TO 12
  17. 400  READ M$(K),J(K)
  18. 420  NEXT K
  19. 440  FOR K = 0 TO 6
  20. 460  READ B$(K)
  21. 480  NEXT K
  22. 500  REM <CTRL-J>--MAIN PROGRAM--<CTRL-J>
  23. 520  CALL  -936: INVERSE : VTAB 24
  24. 540  FOR K = 1 TO 40: PRINT " ";: GOSUB 3620: NEXT K
  25. 560  FOR K = 1 TO 9: PRINT "*<";: GOSUB 3620: NEXT K
  26. 580  PRINT "DATE";: FOR K = 1 TO 9: PRINT ">*";: GOSUB 3620
  27. 600  NEXT K
  28. 620  FOR K = 1 TO 40: PRINT " ";: GOSUB 3620: NEXT K: NORMAL 
  29. 640  FOR K = 1 TO 20: PRINT : GOSUB 3620
  30. 660  PRINT "JAN 1982                       MARK 4.1"
  31. 680  FOR K = 1 TO 16: PRINT : GOSUB 3620
  32. 700  NEXT K
  33. 720  VTAB 10: PRINT "  <1>--A CALENDAR"
  34. 740  GOTO 2960
  35. 760  HOME : PRINT 
  36. 780 FLAG = 0:U = 0
  37. 800  HOME : PRINT 
  38. 820  PRINT "ENTER THE MONTH"; TAB( 20);
  39. 840  INPUT P$: PRINT 
  40. 860 P$ =  LEFT$(P$,3)
  41. 880  FOR M = 1 TO 12
  42. 900  IF P$ = M$(M)  THEN 960
  43. 920  NEXT M
  44. 940  GOTO 820
  45. 960  PRINT "DO YOU WANT THE"
  46. 980  PRINT "  YEAR CALCULATED"
  47. 1000  INPUT "             (Y/N) ?";A$
  48. 1020  PRINT 
  49. 1040  PRINT : PRINT "ENTER THE DAY"
  50. 1060  PRINT "  OF THE MONTH"; TAB( 20);
  51. 1080  INPUT D: PRINT 
  52. 1100  IF D = 29  AND P$ = "FEB"  THEN 1180
  53. 1120  IF D <1  THEN 1160
  54. 1140  IF J(M) =  >D  THEN 1240
  55. 1160  PRINT "REALISTIC NUMERIC INPUT IS REQUIRED.": GOTO 1040
  56. 1180  INVERSE : PRINT " <CTRL-G>SPECIAL CASE<CTRL-G> ": NORMAL 
  57. 1200  PRINT 
  58. 1220 FLAG = 1
  59. 1240 A$ =  LEFT$(A$,1)
  60. 1260  IF A$ = "Y"  THEN 1560
  61. 1280  GOSUB 3200
  62. 1300  PRINT "ENTER THE YEAR"; TAB( 20);: INPUT Y
  63. 1320  IF P$ < >"FEB"  THEN 1440
  64. 1340  IF D <29  THEN 1440
  65. 1360  IF Y = 2000  THEN  GOTO 1440
  66. 1380  IF FLAG = 1  AND Y/100 =  INT(Y/100)  THEN 1420
  67. 1400  IF FLAG = 1  AND Y/4 =  INT(Y/4)  THEN 1440
  68. 1420  PRINT : PRINT "PLEASE ENTER A ";: INVERSE : PRINT " LEAPYEAR ": NORMAL : PRINT : GOTO 1300
  69. 1440  PRINT : PRINT 
  70. 1460  GOSUB 3280
  71. 1480  PRINT  TAB( 3);P$;" ";D","Y;" IS A ";
  72. 1500  INVERSE : PRINT " "B$(E)" ": NORMAL 
  73. 1520  IF X =  -1  THEN  GOTO 2840
  74. 1540  VTAB 24: HTAB 4: PRINT "HIT RETURN TO CONTINUE";: GET A$: GOTO 2920
  75. 1560  GOSUB 3200
  76. 1580  PRINT "TYPE IN THE"
  77. 1600  PRINT "  DAY OF THE WEEK"; TAB( 20);
  78. 1620  INPUT W$: PRINT : PRINT 
  79. 1640 W$ =  LEFT$(W$,2)
  80. 1660  FOR K = 0 TO 6
  81. 1680 Z$(K) =  LEFT$(B$(K),2)
  82. 1700  NEXT K
  83. 1720  FOR K = 0 TO 6
  84. 1740  IF W$ = Z$(K)  THEN 1840
  85. 1760  NEXT K
  86. 1780  PRINT "TYPE THE FIRST 2 LETTERS"
  87. 1800  PRINT "  OF THE DAY OF THE WEEK": PRINT 
  88. 1820  GOTO 1580
  89. 1840  IF FLAG = 1  THEN Q = 4
  90. 1860  IF FLAG = 0  THEN Q = 1
  91. 1880  FOR Y = 1996 TO 1801  STEP  -Q
  92. 1900  IF Q = 4  AND Y = 1900  THEN 2040
  93. 1920  GOSUB 3320
  94. 1940  IF U = 8  THEN  PRINT 
  95. 1960  IF U = 8  THEN U = 0
  96. 1980  IF E = K  THEN  INVERSE : PRINT Y;: NORMAL : PRINT " ";
  97. 2000 J(2) = 28
  98. 2020  IF E = K  THEN U = U +1
  99. 2040  NEXT Y
  100. 2060  VTAB 22: HTAB 4: PRINT "HIT RETURN TO CONTINUE";: GET A$
  101. 2080  GOTO 2920
  102. 2100  REM --<CTRL-J>BLANK SCREEN--<CTRL-J>
  103. 2120  CALL  -936
  104. 2140  PRINT : PRINT : PRINT 
  105. 2160  REM <CTRL-J>--CALENDAR INPUT--<CTRL-J>
  106. 2180 J(2) = 28
  107. 2200  PRINT "TYPE IN THE DATE, USING THIS FORM": PRINT 
  108. 2220  INPUT "    25,JAN,1981     ";D,P$,Y
  109. 2240  GOSUB 3660
  110. 2260  GOSUB 3200
  111. 2280  GOSUB 3280
  112. 2300  IF D >J(M)  THEN  PRINT : INVERSE : PRINT " TOO MANY DAYS ": NORMAL : PRINT : GOTO 2200
  113. 2320  IF D <1  THEN  PRINT : PRINT "THERE MUST BE SOME DAYS IN THIS MONTH": PRINT : GOTO 2200
  114. 2340  REM <CTRL-J>--CALENDAR HEADING--<CTRL-J>
  115. 2360  PRINT 
  116. 2380  PRINT "THAT DAY FALLS ON A ";
  117. 2400  INVERSE : PRINT "<<"B$(E)">>"
  118. 2420  NORMAL 
  119. 2440  IF Q =  -1  THEN Q =  -2: PRINT : PRINT : GOTO 2200
  120. 2460  IF Q =  -2  THEN D1 =  ABS(D1 -W)
  121. 2480  IF Q =  -2  THEN  PRINT : PRINT "THERE ARE ";D1" DAYS BETWEEN DATES": PRINT : GOTO 1540
  122. 2500  PRINT : PRINT : PRINT 
  123. 2520  REM <CTRL-J>--PRINT A CALENDAR--<CTRL-J>
  124. 2540  PRINT  TAB( 15);M$(M);"  ";Y: PRINT 
  125. 2560 D1 = 1: GOSUB 3200
  126. 2580  GOSUB 3280: GOSUB 3560
  127. 2600  PRINT "  SUN  MON  TUE  WED  THU  FRI  SAT": PRINT 
  128. 2620  FOR K = 1 TO J(M)
  129. 2640  IF K >9  THEN D1 = 0
  130. 2660  PRINT  TAB( 4 +(5 *S) +L +D1);
  131. 2680  IF K = D  THEN  INVERSE 
  132. 2700  PRINT K;: NORMAL 
  133. 2720 L = L +5
  134. 2740  IF S *5 +L >30  THEN L = 0
  135. 2760  IF L = 0  THEN  PRINT "            "
  136. 2780  IF L = 0  THEN S = 0
  137. 2800  NEXT K
  138. 2820 L = 0
  139. 2840  PRINT : IF X =  -1  THEN  PRINT : PRINT "DATE MAY NOT BE CORRECT, YOU ARE OUT OF THE RANGE OF THIS PROGRAM !!!"
  140. 2860  PRINT : PRINT : PRINT "PRESS ANY KEY TO CONTINUE";
  141. 2880  GET A$: HOME : PRINT : PRINT 
  142. 2900  REM <CTRL-J>--MAIN MENU--<CTRL-J>
  143. 2920 Q = 0:D1 = 0
  144. 2940  CALL  -936: VTAB 4: PRINT "  <1>--ANOTHER CALENDAR"
  145. 2960  PRINT : PRINT "  <2>--FIND DAYS OF THE WEEK"
  146. 2980  PRINT : PRINT "  <3>--DAYS BETWEEN DATES
  147. 3000  PRINT : PRINT "  <4>--QUIT"
  148. 3020  INPUT "               WHICH  ";K
  149. 3040  IF K <1  THEN  GOTO 2920
  150. 3060  IF K = 1  THEN  GOTO 2120
  151. 3080  IF K = 2  THEN  GOTO 760
  152. 3100  IF K = 3  THEN Q =  -1: GOTO 2120
  153. 3120  PRINT : PRINT : PRINT "             GOOD BYE"
  154. 3160  END 
  155. 3180  REM <CTRL-J>--SUBROUTINE I--<CTRL-J>
  156. 3200  IF M <3  THEN N = M +13:G = 1
  157. 3220  IF M >2  THEN N = M +1:G = 0
  158. 3240  RETURN 
  159. 3260  REM <CTRL-J>--SUBROUTINE II--<CTRL-J>
  160. 3280 A1 = Y/1000 - INT(Y/1000)
  161. 3300  IF A1 = 0  THEN J(2) = 29: GOTO 3400
  162. 3320 A2 = Y/100 - INT(Y/100)
  163. 3340  IF A2 = 0  THEN  GOTO 3400
  164. 3360 A3 = Y/4 - INT(Y/4)
  165. 3380  IF A3 = 0  THEN J(2) = 29
  166. 3400 W =  INT((Y -G) *365.25) + INT((N *30.6) +.01)
  167. 3420 S = W -621048
  168. 3440 W = W +D -621049
  169. 3460  IF D1 = 0  THEN D1 = W
  170. 3480 E =  INT(((W/7) - INT(W/7)) *7 +.01)
  171. 3500  IF W <0  OR W >146070  THEN X =  -1
  172. 3520  RETURN 
  173. 3540  REM <CTRL-J>--SUBROUTINE III--<CTRL-J>
  174. 3560 S =  INT(((S/7) - INT(S/7)) *7 +.05)
  175. 3580  RETURN 
  176. 3600  REM <CTRL-J>--SUBROUTINE IV--<CTRL-J>
  177. 3620  FOR J = 1 TO 30: NEXT J
  178. 3640  RETURN 
  179. 3660  REM <CTRL-J>--SUBROUTINE V--<CTRL-J>
  180. 3680 P$ =  LEFT$(P$,3)
  181. 3700  FOR M = 1 TO 13: IF P$ = M$(M)  THEN  RETURN 
  182. 3720  NEXT M
  183. 3740  IF M = 13  THEN  POP : GOTO 2200
  184. 3760  RETURN